home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TSR / STAY50 / SRMSGU.PAS < prev   
Pascal/Delphi Source File  |  1988-11-28  |  12KB  |  283 lines
  1.  
  2. {$I direct.inc}
  3. {───────────────────────────────────────────────────────────────────────────}
  4. {  SRMSGU.PAS                                                               }
  5. {                                                                           }
  6. {  Copyright (C) 1988  L.H.Ferris                                           }
  7. {───────────────────────────────────────────────────────────────────────────}
  8.  
  9.   unit SRMSGU  ;
  10.   {────────────────────────────────────────────────────────────────────────}
  11.                                interface
  12.   {────────────────────────────────────────────────────────────────────────}
  13.  
  14.  
  15.   type
  16.      string8 = string[8]  ;
  17.      msgptr  = pointer    ;
  18.  
  19.  
  20.    Procedure MakeMailbox (pMailboxname : string8) ;
  21.    Procedure Send   (pMailboxname : string8 ; pmsgptr: pointer ) ;
  22.    Procedure Receive( pMailboxname:string8 ; var pmsgptr:pointer ) ;
  23.   {────────────────────────────────────────────────────────────────────────}
  24.                               implementation
  25.   {────────────────────────────────────────────────────────────────────────}
  26.   uses  sr50,                     { StayResident Kernel           }
  27.         sr50subs  ;               { StayResident subroutines      }
  28.    type
  29.  
  30.      msgrecptr   = ^msgrec      ;    { pointer to msgrec in mailbox    }
  31.      msgrec = record
  32.        msgreclink   : msgrecptr ;    { ptr to next msg in mailbox   }
  33.        msgprocid    : word      ;    { id of sending process        }
  34.        msgrecdata   : pointer   ;    { ptr to user data             }
  35.      end {msgrec}               ;
  36.  
  37.      mailboxptr = ^ mailbox     ;
  38.      mailbox = record
  39.       maillink     : mailboxptr  ;
  40.       mailname     : string8     ;
  41.       mailLock     : word        ;
  42.       mailsendhead : msgrecptr   ;   { pointer to head of message   queue }
  43.       mailsendtail : msgrecptr   ;   { pointer to tail of message   queue }
  44.       mailwaithead : msgrecptr   ;   { pointer to head of waiting   queue }
  45.       mailwaittail : msgrecptr   ;   { pointer to tail of waiting   queue }
  46.      end {mailbox}               ;
  47.  
  48.  
  49.    var
  50.     f1stMailbox : mailboxptr    ;    { anchor for first mailbox     }
  51.   {────────────────────────────────────────────────────────────────────}
  52.   {                  Dummy routines for testing                        }
  53.   {────────────────────────────────────────────────────────────────────}
  54. (*************
  55.    const
  56.      msgwait = 0010 ;
  57.    Procedure Suspend(pSRBid : word; msgwait : word)  ;
  58.     begin end ;
  59.    Procedure UnSuspend(pSRBid : word; msgwait:word ) ;
  60.     begin end ;
  61.    Function Getsrbid : word ;
  62.     begin
  63.     Getsrbid := 1 ;
  64.     end ;
  65.    Procedure Yield ;
  66.    Begin end;
  67. ******************)
  68.   {────────────────────────────────────────────────────────────────────}
  69.   {                       Lock/UnLock                                  }
  70.   {────────────────────────────────────────────────────────────────────}
  71.   {              Loop until exclusive control of a semaphore           }
  72.   {────────────────────────────────────────────────────────────────────}
  73.    Procedure Lock(var Lockword : word ) ;
  74.      Begin
  75.       Repeat
  76.         while Lockword <>0 do ;   { spin for available lock }
  77.         inc(Lockword)         ;   { try to get the lock     }
  78.         if Lockword = 1 then exit { if locked, exit with it }
  79.          else dec(Lockword)   ;   { else, reset lock        }
  80.       Until false             ;   { spin for available lock }
  81.     End {Lock} ;
  82.  
  83.    Procedure UnLock(var Lockword : word ) ;
  84.      Begin
  85.       Lockword := 0 ;
  86.     End {UnLock} ;
  87.   {────────────────────────────────────────────────────────────────────}
  88.   {                           Make Mail Box                            }
  89.   {────────────────────────────────────────────────────────────────────}
  90.   {     Make a mailbox by "Mailboxname" and place on mailbox chain     }
  91.   {────────────────────────────────────────────────────────────────────}
  92.    Procedure MakeMailbox(pMailboxname : string8) ;
  93.     var
  94.      mbptr : mailboxptr ;
  95.     begin
  96.       getmem(mbptr, sizeof(mailbox) );
  97.       if mbptr = nil then
  98.        errormsg(haltlevel,'MakeMailbox: memory exhausted') ;
  99.       mbptr^.mailname      := UpperCase(pmailboxname) ;
  100.       mbptr^.maillock      := 0            ;
  101.       mbptr^.mailsendhead  := nil          ;
  102.       mbptr^.mailsendtail  := nil          ;
  103.       mbptr^.mailwaithead  := nil          ;
  104.       mbptr^.mailwaittail  := nil          ;
  105.       SingleTask                        ;
  106.       mbptr^.maillink   := f1stMailbox  ;
  107.       f1stMailbox       := mbptr        ;
  108.       Multitask                         ;
  109.  
  110.    End {Procedure MakeMailbox} ;
  111.   {────────────────────────────────────────────────────────────────────}
  112.   {                             OnWaitList                             }
  113.   {────────────────────────────────────────────────────────────────────}
  114.   {   Return "true" if this procid is waiting on Receive mailbox chain }
  115.   {────────────────────────────────────────────────────────────────────}
  116.    Function OnWaitList( pMailboxptr:mailboxptr ;
  117.                         pmsgprocid :word  )    : boolean ;
  118.     var
  119.      mbptr  : mailboxptr ;
  120.      recptr : msgrecptr  ;
  121.      found  : boolean    ;
  122.     Begin
  123.      OnWaitList := false      ;
  124.      found      := false      ;
  125.      with pMailboxptr^ do begin
  126.        if mailwaithead = nil then exit ; { wait list is empty }
  127.  
  128.        recptr := mailwaithead     ;
  129.  
  130.        while (recptr <> nil) and (NOT found) do begin
  131.         if recptr^.msgprocid = pmsgprocid then begin
  132.              found      := true ;
  133.              OnWaitList := true ;
  134.              exit          ;
  135.              end           ;
  136.           recptr := recptr^.msgreclink ;
  137.        end {while recptr..}       ;
  138.  
  139.      end {with pMail...}    ;
  140.     End { OnWaitList } ;
  141.   {────────────────────────────────────────────────────────────────────}
  142.   {                             Send                                   }
  143.   {────────────────────────────────────────────────────────────────────}
  144.   {            Enque message ptr on Send (Named) Mailbox chain         }
  145.   {────────────────────────────────────────────────────────────────────}
  146.    Procedure Send( pMailboxname:string8 ; pmsgptr:pointer ) ;
  147.     var
  148.      mbptr  : mailboxptr ;
  149.      recptr : msgrecptr  ;
  150.      found  : boolean    ;
  151.      tid    : word       ;
  152.  
  153.     begin
  154.       tid   := GetSRBid    ;
  155.       mbptr := f1stMailbox ;
  156.       found := false  ;
  157.  
  158.         while (mbptr <> nil) and (NOT found) do    { find named mailbox }
  159.           if mbptr^.mailname = UpperCase(pMailboxname)
  160.              then found := true
  161.              else mbptr := mbptr^.maillink ;
  162.         if NOT found then
  163.           errormsg(warnlevel,'Send: Mailbox name error: '+pMailboxname) ;
  164.  
  165.       Lock(mbptr^.maillock)     ; { get exclusive control of mailbox }
  166.  
  167.       WITH mbptr^ do begin
  168.         new(recptr)           ;
  169.         recptr^.msgrecdata := pmsgptr  ;        { store ptr to user data }
  170.         recptr^.msgprocid  := tid      ;        { store id of sender     }
  171.  
  172.         if mailsendhead = nil then              { Queue the message ptr  }
  173.             mailsendhead := recptr
  174.         else
  175.            mailsendtail^.msgreclink := recptr   ;
  176.  
  177.          recptr^.msgreclink := nil              ;
  178.          mailsendtail := recptr                 ;
  179.  
  180.      { Unsuspend first process (which is not this id )waiting for }
  181.      { messages in this mailbox                                   }
  182.  
  183.         if mailwaithead = nil then {nothing}     { Nobody waiting for msg  }
  184.         else begin                               { Unsuspend waiting tasks }
  185.           Recptr := mailwaithead               ; { ptr to waiting queue    }
  186.           mailwaithead := Recptr^.msgreclink   ; { ptr to nxt waiting proc }
  187.           if mailwaithead = nil                  { Tail get nil if head is }
  188.              then mailwaittail := nil          ;
  189.           UnSuspend(recptr^.msgprocid,msgwait) ; { remove suspended status }
  190.           dispose(Recptr)                      ; { release chained element }
  191.         end {else mailwaithead..}              ;
  192.         UnLock(maillock)                       ; { release mailbox control }
  193.       end {with mbptr..} ;
  194.    End {Procedure Send} ;
  195.   {────────────────────────────────────────────────────────────────────}
  196.   {                             Receive                                }
  197.   {────────────────────────────────────────────────────────────────────}
  198.   {        Receive/wait for message ptr from Receive mailbox chain.    }
  199.   {────────────────────────────────────────────────────────────────────}
  200.    Procedure Receive( pMailboxname:string8 ; var pmsgptr:pointer ) ;
  201.     var
  202.      mbptr  : mailboxptr ;       { mailbox pointer }
  203.      recptr : msgrecptr  ;       { receive msg ptr }
  204.      found  : boolean    ;       { success flag    }
  205.      tid    : word       ;
  206.     begin
  207.  
  208.       tid   := GetSRBid ;
  209.       mbptr := f1stMailbox  ;           { first mainbox pointer }
  210.       found := false  ;
  211.                                         { find mailbox by name }
  212.       while (mbptr <> nil) and (NOT found) do
  213.           if mbptr^.mailname = UpperCase(pMailboxname)
  214.              then found := true
  215.              else mbptr := mbptr^.maillink ;
  216.         if NOT found then begin
  217.           if debug then
  218.              errormsg(warnlevel,
  219.                'Receive: Mailbox name error: ' +pMailboxname) ;
  220.           pmsgptr := nil ; exit ;
  221.           end ;
  222.  
  223.         found := false                ;
  224.  
  225.         Lock(mbptr^.MailLock)         ; { Get exclusive control of mailbox }
  226.  
  227.         REPEAT
  228.           WITH mbptr^ do begin
  229.            if mailsendhead <> nil then begin       { Return available message }
  230.              recptr := mailsendhead          ;     { but not ones we sent     }
  231.              if recptr^.msgprocid <> tid then begin
  232.                mailsendhead := recptr^.msgreclink ;
  233.                if mailsendhead = nil then
  234.                   mailsendtail := nil        ;
  235.                pmsgptr := recptr^.msgrecdata ; { pointer to user data }
  236.                dispose(recptr)               ; { free message record  }
  237.                found   := true               ;
  238.              end {if..tid}                   ;
  239.            end {if msgsendhead..}            ;
  240.  
  241.  
  242.           if NOT found then begin                { suspend caller when no msgs }
  243.             if NOT onwaitlist(mbptr,tid)         { and place  on waiting chain }
  244.               then begin                         { if not there already        }
  245.               new(recptr)                    ;
  246.               recptr^.msgrecdata := pmsgptr  ;        { store ptr to user data }
  247.               recptr^.msgprocid  := tid      ;        { store id of caller     }
  248.               if mailwaithead = nil then              { Queue the message ptr  }
  249.                  mailwaithead := recptr
  250.               else
  251.                  mailwaittail^.msgreclink
  252.                                   := recptr  ;
  253.               recptr^.msgreclink := nil      ;
  254.               mailwaittail := recptr         ;
  255.               end {if NOT onwaitlist}        ;
  256.           end {if NOT found..}               ;
  257.  
  258.  
  259.           if NOT found then begin
  260.             SingleTask                       ;   {** Critical section **}
  261.             UnLock(mbptr^.mailLock)          ;   { release the mailbox  }
  262.             suspend(tid,msgwait)             ;   { without a taskswitch }
  263.             MultiTask                        ;
  264.             Yield                            ;   { release CPU control here }
  265.             Lock(mbptr^.mailLock)            ;   { reacquire mailbox lock   }
  266.           end {if NOT found}                 ;
  267.          end {with mbptr^..}  ;
  268.  
  269.         UNTIL found           ;
  270.      UnLock(mbptr^.MailLock)         ; { Release control of mailbox }
  271.  
  272.    End {Procedure Receive} ;
  273.   {────────────────────────────────────────────────────────────────────}
  274.   {                           initialization                           }
  275.   {────────────────────────────────────────────────────────────────────}
  276.  
  277.   begin { SRMSGU initialization }
  278.  
  279.    f1stMailbox := nil ;
  280.  
  281.   end   { SRMSGU initialization } .
  282.  
  283.